perm filename FREE.PAS[AL,HE]4 blob
sn#697205 filedate 1983-01-26 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00012 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 (*$E+ Routines to free up an AL program when we're done with it *)
C00008 00003 (* datatype definitions *)
C00014 00004 (* statement definitions *)
C00018 00005 (* auxiliary definitions: variable, etc. *)
C00020 00006 (* definition of the ubiquitous NODE record *)
C00026 00007 (* records for parser: ident, token, resword *)
C00029 00008 (* process descriptor blocks & environment record definitions *)
C00032 00009 (* definition of AL-ARM messages *)
C00034 00010 (* aux routines from elsewhere *)
C00035 00011 (* auxiliary routines: freStrng, freeVaridef, freeToken, freeNode *)
C00040 00012 (* routine to free up a program once we're done with it: freeStatement *)
C00045 ENDMK
C⊗;
(*$E+ Routines to free up an AL program when we're done with it *)
(*$S3000 use a large codesize *)
program free;
(* The following bits are used during calls to the ARM servo *)
const
YARMDEV = (*1B*) 1; (* device bits for: yellow arm *)
YHANDDEV = (*2B*) 2;
BARMDEV = (*4B*) 4;
BHANDDEV = (*10B*) 8;
VISEDEV = (*20B*) 16;
DRIVERDEV = (*40B*) 32;
GARMDEV = (*100B*) 64;
GHANDDEV = (*200B*) 128;
RARMDEV = (*400B*) 256;
RHANDDEV = (*1000B*) 512;
YELARM = 1; (* Yellow arm *)
BLUARM = 4; (* Blue arm *)
FTABLE = (*400B*) 256; (* Force trans (C) in table coordinates *)
FHAND = 0; (* " " " " hand coordinate system *)
XFORCE = 0; (* Force along X direction of C *)
YFORCE = (*1000B*) 512; (* " " Y " " " *)
ZFORCE = (*2000B*) 1024; (* " " Z " " " *)
XMOMENT = (*3000B*)1536; (* Moment about X direction of C *)
YMOMENT = (*4000B*)2048; (* " " Y " " " *)
ZMOMENT = (*5000B*)2560; (* " " Z " " " *)
FSTOP = (*10000B*)4096; (* In addition to starting cmon, stop arm *)
SIGMAG = (*20000B*)8192; (* Test only magnitude of forces *)
SIGGE = (*100000B*) 32768; (* Start cmon if force ≥ specified value *)
SIGLT = 0; (* " " " " < " " *)
BARMPOWER = 1; (* bit defs - used in response to initarmscmd *)
YARMPOWER = 2;
GARMPOWER = 4;
RARMPOWER = (*10B*) 8;
GARMCAL = (*400B*) 256;
RARMCAL = (*1000B*) 512;
NULLINGCB = 1; (* control bits for trajectory specs *)
WOBBLECB = 2;
DURLBCB = (*20B*) 16; (* Duration: lower, upper & exact bounds *)
DURUBCB = (*40B*) 32;
DUREQCB = (*60B*) 48;
VELOCCB = (*100B*) 64;
CODECB = (*200B*) 128;
VIAPTCB = (*400B*) 256;
DEPRPTCB = (*1000B*) 512;
APPRPTCB = (*2000B*) 1024;
DESTPTCB = (*10000B*) 4096;
CR = 13; (* Carriage return *)
LF = 10; (* Line feed *)
(* random type declarations for OMSI/SAIL compatibility *)
type
(* ascii = char; *)
atext = packed file of ascii;
(* atext = text; *)
(* the following get used by ALLOC for misc record types -
i.e. to fake out Pascal's type checking mechanism *)
s2p = ↑s2;
s2 = record next: s2p; filler: integer; end;
s4p = ↑s4;
s4 = record next: s4p; filler: array [1..3] of integer; end;
s8p = ↑s8;
s8 = record next: s8p; filler: array [1..7] of integer; end;
s10p = ↑s10;
s10 = record next: s10p; filler: array [1..9] of integer; end;
s11p = ↑s11;
s11 = record next: s11p; filler: array [1..10] of integer; end;
s12p = ↑s12;
s12 = record next: s12p; filler: array [1..11] of integer; end;
(* Here are the pointer types, defined later... *)
vectorp = ↑vector;
transp = ↑trans;
strngp = ↑strng;
eventp = ↑event;
framep = ↑frame;
statementp = ↑statement;
varidefp = ↑varidef;
nodep = ↑node;
identp = ↑ident;
tokenp = ↑token;
reswordp = ↑resword;
pdbp = ↑pdb;
envheaderp = ↑envheader;
enventryp = ↑enventry;
environp = ↑environment;
cmoncbp = ↑cmoncb;
(* datatype definitions *)
datatypes = (pconstype, varitype, svaltype, vectype, rottype, transtype,
frametype, eventtype, strngtype, labeltype, proctype, arraytype,
reftype, valtype, cmontype, nulltype, undeftype,
dimensiontype, mactype, macargtype);
scalar = real;
u = (used,free);
vector = record case u of
used: (refcnt: integer; val: array [1..3] of real);
free: (next: vectorp);
end;
trans = record case u of
used: (refcnt: integer; val: array [1..3,1..4] of real);
free: (next: transp);
end;
cstring = packed array [1..10] of ascii;
c4str = packed array [1..4] of ascii;
strng = record
next: strngp;
ch: cstring;
end;
event = record
count: integer;
waitlist: pdbp;
end;
frame = record
vari: varidefp; (* back pointer to variable name & info *)
calcs: nodep; (* affixment info *)
case ftype: boolean of (* frame = true, device = false *)
true: (valid: integer; val, depr: transp; dcntr: integer; dev: framep);
false: (mech: integer; sdev: boolean);
(* sdev = true for scalar devices, false for frames *)
end;
byte = 0..255; (* doesn't really belong here, but... *)
(* statement definitions *)
stmntypes = (progtype, blocktype, coblocktype, endtype, coendtype,
fortype, iftype, whiletype, untiltype, casetype,
calltype, returntype,
printtype, prompttype, pausetype, aborttype, assigntype,
signaltype, waittype, enabletype, disabletype, cmtype,
affixtype, unfixtype,
movetype,operatetype,opentype,closetype,centertype,floattype,
stoptype, retrytype, toarmtype,
requiretype, definetype, macrotype, commenttype, dimdeftype,
setbasetype, wristtype, saytype, declaretype, emptytype,
evaltype);
(* more??? *)
statement = packed record
next, last: statementp;
stlab: varidefp;
exprs: nodep; (* any expressions used by this statement *)
nlines: integer;
bpt,bad: boolean;
case stype: stmntypes of
progtype: (pcode: statementp; errors: integer);
blocktype,
declaretype,
endtype,
coendtype: (bcode, bparent: statementp; blkid: identp;
level, numvars: 0..255; variables: varidefp);
coblocktype: (threads: nodep; nthreads: integer; cblkid: identp);
fortype: (forvar, initial, step, final: nodep; fbody: statementp);
whiletype,
untiltype: (cond: nodep; body: statementp);
casetype: (index: nodep; range, ncases: integer; caselist: nodep);
iftype: (icond: nodep; thn, els: statementp);
pausetype: (ptime: nodep);
prompttype,
printtype,
aborttype,
saytype: (plist: nodep; debugLev: integer);
returntype: (retval, rproc: nodep);
evaltype,
calltype,
assigntype: (what, aval: nodep);
affixtype,
unfixtype: (frame1, frame2, byvar, atexp: nodep; rigid: boolean);
signaltype,
waittype: (event: nodep);
movetype,
operatetype,
opentype,
closetype,
centertype,
floattype,
stoptype,
setbasetype,
wristtype: (cf, clauses, fvec, tvec: nodep);
retrytype: (rcode, rparent: statementp; olevel: integer);
cmtype: (oncond: nodep; conclusion: statementp;
deferCm, exprCm: boolean; cdef: varidefp);
enabletype,
disabletype: (cmonlab: varidefp);
requiretype: (rfil: boolean; rfils: strngp; rfilen: integer);
definetype: (macname,mpars: varidefp; macdef: tokenp);
commenttype: (len: integer; str: strngp; cbody: statementp);
dimdeftype: (dimname: varidefp; dimexpr: nodep);
end;
(* auxiliary definitions: variable, etc. *)
varidef = packed record
next,dnext: varidefp;
name: identp;
level: 0..255; (* environment level *)
offset: 0..255; (* environment offset *)
dtype: varidefp; (* to hold the dimension info *)
tbits: 0..15; (* special type bits: array = 1, proc = 2, ref = 4 & ? *)
dbits: 0..15; (* for use by debugger/interpreter *)
case vtype: datatypes of
arraytype: (a: nodep);
proctype: (p: nodep);
labeltype,
cmontype: (s: statementp);
mactype: (mdef: statementp);
macargtype: (marg: tokenp);
pconstype: (c: nodep);
dimensiontype: (dim: nodep);
end;
(* definition of the ubiquitous NODE record *)
nodetypes = (exprnode, leafnode, listnode, clistnode, colistnode, forvalnode,
deprnode, viaptnode, apprnode, destnode, bynode, durnode,
sfacnode, wobblenode, swtnode, nullingnode, wristnode, cwnode,
arrivalnode, departingnode,
ffnode, forcenode, stiffnode, gathernode, cmonnode, errornode,
calcnode, arraydefnode, bnddefnode, bndvalnode,
waitlistnode, procdefnode, tlistnode, dimnode, commentnode,
linearnode, elbownode, shouldernode, flipnode);
exprtypes = ( svalop, (* scalar operators *)
sltop, sleop, seqop, sgeop, sgtop, sneop, (* relations *)
notop, orop, xorop, andop, eqvop, (* logical *)
saddop, ssubop, smulop, sdivop, snegop, sabsop, (* scalar ops *)
sexpop, maxop, minop, intop, idivop, modop,
sqrtop, logop, expop, timeop, (* functions *)
sinop, cosop, tanop, asinop, acosop, atan2op, (* trig *)
vdotop, vmagnop, tmagnop,
vecop, (* vector operators *)
vmakeop, unitvop, vaddop, vsubop, crossvop, vnegop,
svmulop, vsmulop, vsdivop, tvmulop, wrtop,
tposop, taxisop,
transop, (* trans operators *)
tmakeop, torientop, ttmulop, tvaddop, tvsubop, tinvrtop,
vsaxwrop, constrop, ftofop, deproachop, fmakeop, vmkfrcop,
ioop, (* i/o operators *)
queryop, inscalarop,
specop, (* special operators *)
arefop, callop, grinchop, macroop, vmop, adcop, dacop,
badop,
addop, subop, negop, mulop, divop, absop); (* for parsing *)
leaftypes = pconstype..strngtype;
reltypes = sltop..sgtop;
forcetypes = (force,absforce,torque,abstorque,angvelocity);
node = record
next: nodep;
case ntype: nodetypes of
exprnode: (op: exprtypes; arg1, arg2, arg3: nodep; elength: integer);
leafnode: (case ltype: leaftypes of
varitype: (vari: varidefp; vid: identp);
pconstype: (cname: varidefp; pcval: nodep);
svaltype: (s: scalar; wid: integer);
vectype: (v: vectorp);
transtype: (t: transp);
strngtype: (length: integer; str: strngp) ); (* also used by commentnodes *)
listnode: (lval: nodep);
clistnode: (cval: integer; stmnt: statementp; clast: nodep);
colistnode: (prev: nodep; cstmnt: statementp);
forvalnode: (fvar: enventryp; fstep: scalar);
arrivalnode:(evar: varidefp);
deprnode,
apprnode,
destnode: (loc: nodep; code: statementp);
bynode,
viaptnode: (vlist: boolean; via,duration,velocity: nodep; vcode: statementp);
durnode: (durrel: reltypes; durval: nodep);
sfacnode,
wobblenode,
swtnode: (clval: nodep);
nullingnode, (* true = nonulling *)
wristnode, (* = don't zero force wrist *)
cwnode, (* = counter_clockwise *)
elbownode, (* = elbow up *)
shouldernode, (* = right shoulder *)
flipnode, (* = don't flip wrist *)
linearnode: (notp: boolean); (* = linear motion *)
ffnode: (ff,cf: nodep; csys, pdef: boolean); (* true = world, false = hand *)
forcenode: (ftype: forcetypes; frel: reltypes; fval, fvec, fframe: nodep);
stiffnode: (fv, mv, coc: nodep);
gathernode: (gbits: integer);
cmonnode: (cmon: statementp; errhandlerp: boolean);
errornode: (eexpr: nodep);
calcnode: (rigid, frame1: boolean; other: framep; case tvarp: boolean of
false: (tval: transp); true: (tvar: enventryp) );
arraydefnode: (numdims: 1..10; bounds: nodep; combnds: boolean);
bnddefnode: (lower, upper: nodep);
bndvalnode: (lb, ub, mult: integer);
waitlistnode: (who: pdbp; when: integer);
procdefnode:(ptype: datatypes; level: 0..255;
pname, paramlist: varidefp; body: statementp);
tlistnode: (tok: tokenp);
dimnode: (time, distance, angle, dforce: integer);
end;
(* records for parser: ident, token, resword *)
ident = record
next: identp;
length: integer;
name: strngp;
curv: varidefp;
end;
tokentypes = (reswdtype, identtype, constype, comnttype, delimtype, labeldeftype,
macpartype);
constypes = svaltype..strngtype;
reswdtypes = (stmnttype, filtype, clsetype, decltype, optype);
filtypes = (abouttype,alongtype,attype,bytype,defertype,dotype,elsetype,
errmodestype,fromtype,handtype,intype,nonrigidlytype,rigidlytype,
sourcefiletype,steptype,thentype,totype,untltype,viatype,
withtype,worldtype,zeroedtype,oftype,wheretype,nowaittype);
clsetypes = (approachtype,arrivaltype,departuretype,departingtype,durationtype,
errortype,forcetype,forceframetype,forcewristtype,gathertype,
nildeproachtype,nonullingtype,nullingtype,stiffnesstype,
torquetype,velocitytype,wobbletype,
cwtype,ccwtype,stopwaittimetype,angularvelocitytype,
fxtype,fytype,fztype,mxtype,mytype,mztype,
t1type,t2type,t3type,t4type,t5type,t6type,tbltype);
token = record
next: tokenp;
case ttype: tokentypes of
constype: (cons: nodep);
comnttype: (len: integer; str: strngp);
delimtype: (ch: char);
reswdtype: (case rtype: reswdtypes of
stmnttype: (stmnt: stmntypes);
filtype: (filler: filtypes);
clsetype: (clause: clsetypes);
decltype: (decl: datatypes);
optype: (op: exprtypes) );
identtype: (id: identp);
labeldeftype: (lab: varidefp);
macpartype: (mpar: varidefp);
end;
resword = record
next: reswordp;
length: integer;
name: strngp;
case rtype: reswdtypes of
stmnttype: (stmnt: stmntypes);
filtype: (filler: filtypes);
clsetype: (clause: clsetypes);
decltype: (decl: datatypes);
optype: (op: exprtypes);
end;
(* process descriptor blocks & environment record definitions *)
pdb = packed record
next: pdbp; (* for list of active pdb's *)
env: envheaderp;
lex: 0..255; (* lexical level *)
mode: 0..255; (* expression/statement/sub-statement *)
spc: statementp; (* current statement *)
epc: nodep; (* current expression (if any) *)
sp: nodep; (* intermediate value stack *)
cm: cmoncbp; (* if we're a cmon point to our definition *)
mech: framep; (* current device being used *)
priority: 0..255; (* probably never greater than 3? *)
case procp: boolean of (* true if we're a procedure *)
true: (opdb: pdbp); (* pdb to restore when procedure exits *)
false: (evt: eventp); (* event to signal when process goes away *)
end;
envheader = packed record
parent: envheaderp;
env: array [0..4] of environp;
varcnt: 0..255; (* # of variables in use ??? *)
case procp: boolean of (* true if we're a procedure *)
true: (proc: nodep);
false:(block: statementp);
end;
enventry = record
case etype: datatypes of
svaltype: (s: scalar);
vectype: (v: vectorp);
transtype: (t: transp);
frametype: (f: framep);
eventtype: (evt: eventp);
strngtype: (length: integer; str: strngp);
cmontype: (c: cmoncbp);
proctype: (p: nodep; penv: envheaderp);
reftype: (r: enventryp);
arraytype: (a: envheaderp; bnds: nodep);
end;
environment = record
next: environp;
vals: array [0..9] of enventryp;
end;
cmoncb = record
running, enabled: boolean; (* cmon's status *)
cmon: statementp;
pdb: pdbp;
evt: eventp;
fbits: integer; (* bits for force sensing *)
end;
(* definition of AL-ARM messages *)
msgtypes = (initarmscmd,calibcmd,killarmscmd,wherecmd,
abortcmd,stopcmd,movehdrcmd,movesegcmd,
centercmd,operatecmd,movedonecmd,signalcmd,readjtcmd,drivecmd,
setccmd,forcesigcmd,forceoffcmd,biasoncmd,biasoffcmd,setstiffcmd,
zerowristcmd,wristcmd,gathercmd,getgathercmd,readadccmd,writedaccmd);
message = record
cmd: msgtypes;
ok: boolean;
case integer of
1: (dev, bits, n: integer;
(* (dev, bits, n, evt: integer; (* for arm code version *)
evt: eventp;
dur: real;
case integer of
1: (v1,v2,v3: real);
2: (sfac,wobble,pos: real);
3: (val,angle,mag: real);
4: (max,min: real));
2: (fv1,fv2,fv3,mv1,mv2,mv3: real); (* may never use these... *)
3: (t: array [1..6] of real);
end;
(* aux routines from elsewhere *)
procedure relToken(t: tokenp); extern; (* from ALLOC.PAS *)
procedure relNode(n: nodep); extern;
procedure relStrng(n: strngp); extern;
procedure relVector(n: vectorp); extern;
procedure relTrans(n: transp); extern;
procedure relIdent(n: identp); extern;
procedure relVaridef(n: varidefp); extern;
procedure relStatement(n: statementp); extern;
procedure freeIds; extern;
procedure clrBpt(st: statementp); extern; (* from EDIT.PAS *)
procedure flushVar(oldvar: varidefp); extern;
(* auxiliary routines: freStrng, freeVaridef, freeToken, freeNode *)
procedure freeStatement(s: statementp); forward;
procedure freeNode(n: nodep); forward;
procedure freStrng(st: strngp);
var stp: strngp;
begin
while st <> nil do
begin stp := st↑.next; relStrng(st); st := stp end;
end;
procedure freeToken(t: tokenp);
var tp: tokenp;
begin
while t <> nil do
begin
with t↑ do
begin
if ttype = constype then
if cons↑.ltype = svaltype then relNode(cons) else freeNode(cons)
else if ttype = comnttype then freStrng(str);
tp := next;
end;
relToken(t);
t := tp
end;
end;
procedure freeVaridef(v: varidefp);
var vp: varidefp;
begin
while v <> nil do
with v↑ do
begin
if tbits = 2 then freeNode(p) (* procedure definition *)
else if odd(tbits) then freeNode(a) (* array definition *)
else
case vtype of
macargtype: freeToken(marg);
dimensiontype: relNode(dim);
others: begin end; (* nothing to do *)
end;
vp := next;
relVaridef(v);
v := vp;
end;
end;
procedure freeNode (* n: nodep *);
var b: boolean;
begin
b := true;
if n = nil then b := false
else
with n↑ do
case ntype of
exprnode: begin
freeNode(arg1);
freeNode(arg2);
freeNode(arg3);
end;
leafnode: case ltype of
vectype: if v↑.refcnt <= 1 then relVector(v)
else v↑.refcnt := v↑.refcnt - 1;
transtype: if t↑.refcnt <= 1 then relTrans(t)
else t↑.refcnt := t↑.refcnt - 1;
strngtype: if (length <> 2) or (str↑.ch[1] <> chr(CR)) or
(str↑.ch[2] <> chr(LF)) then freStrng(str) else b := false;
end;
listnode: begin
freeNode(lval);
freeNode(next);
end;
clistnode:begin
freeStatement(stmnt);
freeNode(next);
end;
colistnode: begin
freeStatement(cstmnt);
freeNode(next);
end;
deprnode,
apprnode,
destnode: begin
freeNode(loc);
freeStatement(code);
freeNode(next);
end;
viaptnode:begin
freeNode(via);
freeNode(duration);
freeNode(velocity);
freeStatement(vcode);
freeNode(next);
end;
durnode: begin
freeNode(durval);
freeNode(next);
end;
sfacnode,
wobblenode,
swtnode: begin
freeNode(clval);
freeNode(next);
end;
gathernode,
nullingnode,
wristnode,
cwnode: freeNode(next);
ffnode: begin
if pdef then relNode(ff)
else freeNode(ff);
freeNode(next);
end;
forcenode:begin
freeNode(fval);
freeNode(fvec);
freeNode(fframe);
freeNode(next);
end;
stiffnode:begin
freeNode(fv);
freeNode(mv);
freeNode(coc);
freeNode(next);
end;
cmonnode: begin
freeStatement(cmon);
freeNode(next);
end;
errornode:begin
freeNode(eexpr);
end;
calcnode: if not tvarp then relTrans(tval); (* should never see one but *)
arraydefnode: freeNode(bounds);
bnddefnode:begin
freeNode(lower);
freeNode(upper);
freeNode(next);
end;
procdefnode:begin
freeVaridef(paramlist);
relStatement(body↑.next);
freeStatement(body);
end;
tlistnode: freeToken(tok);
end;
if b then relNode(n);
end;
(* routine to free up a program once we're done with it: freeStatement *)
procedure freeStatement(* s: statementp *);
var st,stp: statementp; n: nodep;
begin
if s <> nil then
begin
with s↑ do
begin
if bpt then clrBpt(s); (* keep the debugger tables legit *)
case stype of
progtype: begin
freeStatement(pcode↑.next);
freeStatement(pcode);
freeIds;
end;
blocktype: begin
if blkid <> nil then
begin
freStrng(blkid↑.name);
relIdent(blkid);
end;
st := bcode;
while st <> nil do
begin
stp := st↑.next;
freeStatement(st);
st := stp;
end;
freeVaridef(variables);
end;
endtype,
coendtype: if blkid <> nil then
begin
freStrng(blkid↑.name);
relIdent(blkid);
end;
coblocktype: begin
if cblkid <> nil then
begin
freStrng(cblkid↑.name);
relIdent(cblkid);
end;
if threads <> nil then freeStatement(threads↑.cstmnt↑.next);
freeNode(threads);
end;
fortype: begin
freeNode(forvar);
freeNode(initial);
freeNode(step);
freeNode(final);
if fbody <> nil then freeStatement(fbody↑.next);
freeStatement(fbody);
end;
whiletype,
untiltype: begin
freeNode(cond);
if body <> nil then freeStatement(body↑.next);
freeStatement(body);
end;
casetype: begin
freeNode(index);
n := caselist;
while n <> nil do
if n↑.stmnt = nil then n := n↑.next
else begin freeStatement(n↑.stmnt↑.next); n := nil end;
freeNode(caselist);
end;
iftype: begin
freeNode(icond);
if thn <> nil then freeStatement(thn↑.next);
freeStatement(thn);
freeStatement(els);
end;
pausetype: freeNode(ptime);
prompttype,
printtype,
aborttype: freeNode(plist);
returntype: freeNode(retval);
calltype: freeNode(what);
assigntype: begin
freeNode(what);
freeNode(aval);
end;
affixtype,
unfixtype: begin
freeNode(frame1);
freeNode(frame2);
if stype = affixtype then
begin
freeNode(byvar);
freeNode(atexp);
end;
end;
signaltype,
waittype: freeNode(event);
movetype,
operatetype,
opentype,
closetype,
centertype: begin
freeNode(cf);
freeNode(clauses);
end;
stoptype: freeNode(cf);
cmtype: begin
flushVar(cdef);
if (not exprCm) and (oncond↑.ntype = leafnode) then
if oncond↑.vari↑.name = nil then flushVar(oncond↑.vari);
freeNode(oncond);
freeStatement(conclusion↑.next);
freeStatement(conclusion);
end;
requiretype: freStrng(rfils);
definetype: begin
freeVaridef(mpars);
freeToken(macdef);
end;
commenttype: begin
freStrng(str);
freeStatement(cbody);
end;
dimdeftype: freeNode(dimexpr);
wristtype: begin
freeNode(fvec);
freeNode(tvec);
end;
end;
end;
relStatement(s);
end;
end;
begin
end.